The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/CORE2.PAS

Pascal/Delphi Source File | 1988-09-14 | 21.9 KB | 865 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  9-13-88 7:09 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit Core2;

Interface

Uses
  TPCrt, Globals, TPSTRING, Core1,
  KeyStuff, BinEd, Sort;


procedure GetStr(var inpstr      : StrStd;
                 var ch          : Char;
                 maxlen          : Integer;
                 mode            : Str10);

procedure pause;

function prompt(pr : StrStd; len : Integer; mode : Str10) : StrStd;

function ask(pr : StrPr; mode : Char) : Boolean;

function test_bit(var num; bit_num : Integer) : Boolean;

procedure set_bit(var target; bit_num : Integer);

procedure clear_bit(var target; bit_num : Integer);

procedure FindSect(var req : DosFileName; var drive : Str3; var found : Boolean);

function min(x, y : LongInt) : Integer;

function max(x, y : Integer) : Integer;

function intstr(n, w : Integer) : Str10;

function strint(st : Str10)     : Integer;

function FormTAD(t : tad_array)  : StrTAD;

procedure send_time(size : Integer; var mm, ss : Integer);

procedure timer(var time_on, time_left : Integer);

procedure mesg_insert(TypMsg : Byte);

procedure list(ch : Char);

procedure Write_status_line;

procedure caps_to_mixed(var full_name : StrStd);

procedure ScrollOn;

procedure ScrollOff;

procedure NewExit;

function greg_to_jul(day, mon, yr : Integer) : Real;

procedure check_time;

procedure UserEventCheck(EventNo, KbdFlagInfo : Word);

procedure put_recs;

procedure get_recs;

function less_rec(var x, y : sort_typ) : Boolean;


  {==========================================================================}


Implementation


  procedure GetStr(var inpstr      : StrStd;
                   var ch          : Char;
                   maxlen          : Integer;
                   mode            : Str10);
    { Get a valid input string from the user }

  type
    charset         = set of Char;

  const
    editset : charset = [BS, RUB, CAN, TAB];
    termset : charset = [LF, CR, ETX];
    dispset : charset = [' '..'~'];

  var
    auto, echo, shift_lock, Wrap, question, hard : Boolean;
    i, len, cursor  : Integer;

  begin
    if user_rec.columns < maxlen then
      maxlen := user_rec.columns;
    auto := (Pos('A', mode) > 0); { Line complete when full }
    echo := (Pos('E', mode) > 0); { Display characters on entry }
    shift_lock := (Pos('S', mode) > 0); { Make all characters upper case }
    Wrap := (Pos('W', mode) > 0);
    question := (Pos('?', mode) > 0); { Force inpstr := '?' when encountered }
    hard := (Pos('H', mode) > 0);
    auto := auto or Wrap;         { Wrap forces auto on }
    len := Length(inpstr);
    cursor := Succ(len);
    if echo and (cursor > 0) then
      Write(com, inpstr);
    repeat
      input_time := timeout*18.2;
      time_count := 0;
      repeat
        ch := GetChar;
      until (not Online) or (ch <> NUL) or (input_timeout);
      if shift_lock then
        ch := Upcase(ch);
      case ch of
        TAB :
          repeat
            if echo then
              Write(com, ' ');
            Inc(cursor);
            Insert(' ', inpstr, cursor)
          until (0 = cursor mod 5) or (cursor >= maxlen);
        RUB, BS :
          if cursor > 1 then
            begin
              Write(com, BS, ' ', BS);
              cursor := Pred(cursor);
              Delete(inpstr, cursor, 1)
            end;
        CAN :
          while cursor > 1 do
            begin
              Write(com, BS, ' ', BS);
              cursor := Pred(cursor);
              Delete(inpstr, cursor, 1)
            end;
        ^A :
          while cursor > 1 do
            begin
              if echo then
                Write(com, BS);
              cursor := Pred(cursor)
            end;
        ^S :
          if cursor > 1 then
            begin
              if echo then
                Write(com, BS);
              cursor := Pred(cursor)
            end;
        ^D :
          if cursor <= Length(inpstr) then
            begin
              if echo then
                Write(com, inpstr[cursor]);
              Inc(cursor)
            end;
        ^F :
          while cursor <= Length(inpstr) do
            begin
              if echo then
                Write(com, inpstr[cursor]);
              Inc(cursor)
            end;
        ^G :
          if cursor <= Length(inpstr) then
            Delete(inpstr, cursor, 1);
      else
        if (ch in dispset) and ((len < maxlen) or auto) then
          begin
            if echo then
              Write(com, ch)
            else
              Write(com, '.');
            if (ch = '?') and question and (len = 1) then
              begin
                inpstr := ch;
                ch := CR
              end
            else
              begin
                Insert(ch, inpstr, cursor);
                Inc(cursor)
              end
          end
      end;
      len := Length(inpstr)
    until (not Online) or (ch in termset) or ((len >= maxlen) and auto);
    next_inpstr := '';
    if Wrap and (len >= maxlen) then
      begin
        while (inpstr[len] <> ' ') and (len > 1) do
          len := Pred(len);
        if len > 1 then
          begin
            if echo then
              begin
                for i := Succ(len) to Length(inpstr) do
                  Write(com, BS);
                for i := Succ(len) to Length(inpstr) do
                  Write(com, ' ')
              end;
            next_inpstr := Copy(inpstr, Succ(len), Length(inpstr));
            inpstr := Copy(inpstr, 1, Pred(len))
          end;
      end
    else if hard and (Length(inpstr) > 0) then
      inpstr := inpstr+Chr($0D)+Chr($0A);
  end;


  procedure pause;
    { Pause for user response before continuing }

  var
    ch              : Char;

  begin
    input_time := timeout*18.2;
    time_count := 0;
    Write(com, 'Press any key to continue...');
    if user_rec.noisy then
      Write(com, BEL);
    repeat
      ch := GetChar;
      if (ch = ETX) or (ch = #$0B) or (Upcase(ch) = 'K') or (ch = ESC) then
        abort := True;
    until (not Online) or (ch <> NUL) or (input_timeout);
    Write(com, CR, ' ':28, CR)
  end;



  function prompt(pr : StrStd; len : Integer; mode : Str10) : StrStd;
    { Prompt user, return string and process multiple command buffer }

  type
    charset         = set of Char;

  const
    delim_set : charset = [';', ' ', ','];

  var
    i, J            : Integer;
    reply, Buffer   : StrStd;
    t               : tad_array;

  begin
    reply := '';
    Buffer := '';
    ch := ' ';
    if (not mult_cmds) or (Pos('L', mode) > 0) then {L for literal}
      begin
        Write(com, pr);
        if Pos('M', mode) > 0 then
          Write(com, ' [press "?" for menu]');
        Write(com, '> ');
        if user_rec.noisy then
          Write(com, BEL);
        GetStr(Buffer, ch, len, mode);
      end
    else
      Buffer := Cmd_Queue;        {feed in from queue}
    if Pos('L', mode) = 0 then
      begin                       {not literal, process mult. commands}
        i := 0;
        J := 0;
        repeat
          Inc(i);
          if (Pos('N', mode) > 0) and (Buffer[i] = ' ') then
            Inc(i);
          if Buffer[i] in delim_set then
            J := i;
        until (i >= Length(Buffer)) or (Buffer[i] in delim_set);
        if J > 0 then
          begin
            mult_cmds := True;
            reply := Copy(Buffer, 1, J-1); {get command from buffer}
            Delete(Buffer, 1, J); {remove cmd and delimeter}
            if Buffer = '' then
              begin
                mult_cmds := False;
                Cmd_Queue := '';
              end
            else
              Cmd_Queue := Buffer; {save balance for next command}
            if reply = '' then
              reply := ' ';
            if macro_in_progress and (reply = Chr(13)) then
              reply := ' ';
          end
        else
          begin
            mult_cmds := False;
            Cmd_Queue := '';
            reply := Buffer;      {for single commands}
            if reply = '' then
              reply := ' ';       {so we wont bomb ch assignments}
            if macro_in_progress and (reply = Chr(13)) then
              reply := ' ';
          end;
        if macro_in_progress then
          Delay(500);
      end                         {not literal}
    else
      begin                       {literal}
        reply := Buffer;
        mult_cmds := False;
        Cmd_Queue := '';
      end;
    WriteLn(com);
    prompt := reply;
  end;                            {prompt}



  function ask(pr : StrPr; mode : Char) : Boolean;
    { Ask yes-or-no question and return TRUE for 'Y', FALSE otherwise }

  var
    ch              : Char;
    temp            : string[1];

  begin
    if user_rec.noisy then
      Write(com, BEL);
    repeat
      if mode = 'N' then
        temp := Copy(prompt(pr+' [y/N] ? >', 1, 'ES'), 1, 1)
      else
        temp := Copy(prompt(pr+' [Y/n] ? >', 1, 'ES'), 1, 1);
      ch := temp[1];
    until (ch in ['Y', 'N', ' ']) or (not Online);
    if ch = 'Y' then
      ask := True
    else if ch = 'N' then
      ask := False
    else if mode = 'Y' then
      ask := True
    else
      ask := False;
  end;


  function test_bit(var num; bit_num : Integer) : Boolean;

  var
    subject         : Integer absolute num;
    dummy           : Integer;

  begin
    dummy := subject;
    dummy := dummy shr bit_num;
    if Odd(dummy) then
      test_bit := True
    else
      test_bit := False;
  end;


  procedure set_bit(var target; bit_num : Integer);

  var
    subject         : Integer absolute target;
    mask            : Integer;

  begin
    mask := 1 shl bit_num;
    subject := subject or mask;
  end;



  procedure clear_bit(var target; bit_num : Integer);

  var
    subject         : Integer absolute target;
    mask            : Integer;

  begin
    mask := not(1 shl bit_num);
    subject := subject and mask;
  end;



  procedure FindSect(var req : DosFileName; var drive : Str3; var found : Boolean);
    { Find file section from requested name }

  var
    This            : SectPtr;
    sect_count      : Integer;
    located         : Boolean;

  begin
    This := SectBase;
    located := False;
    sect_count := 1;
    while (not located) and (This <> nil) do
      begin
        located := (This^.SectName = req) or (strint(req) = sect_count);
        if ((not cold) and (not((user_rec.access >= This^.SectAccs) or (test_bit
          (user_rec.conf_flags, This^.SectConf))))) then
          begin
            Dec(sect_count);
            located := False
          end;
        if located then
          begin
            drive := This^.SectDrive+':\';
            req := This^.SectName
          end;
        This := This^.next;
        Inc(sect_count);
      end;
    found := located;
  end;



  function min(x, y : LongInt) : Integer;
    { Return minimum of two integers }

  begin
    if x < y then
      min := x
    else
      min := y
  end;



  function max(x, y : Integer) : Integer;
    { Return greater of two integers }

  begin
    if x > y then
      max := x
    else
      max := y
  end;



  function intstr(n, w : Integer) : Str10;
    { Return a string value (width 'w')for the input integer ('n') }

  var
    st              : Str10;

  begin
    Str(n:w, st);
    intstr := st
  end;



  function strint(st : Str10)     : Integer;
    { Convert string to integer }

  var
    x, code         : Integer;

  begin
    if st[1] = '+' then
      Delete(st, 1, 1);
    if st = '' then
      code := 1
    else
      Val(st, x, code);
    if code = 0 then
      strint := x
    else
      strint := 0                 { Error, return with 0 }
  end;



  function FormTAD(t : tad_array)  : StrTAD;
    { Build printable string of current time and date }

  const
    day : array[0..6] of string[6] = ('Sun', 'Mon', 'Tues', 'Wednes', 'Thurs', 'Fri', 'Satur');
    month           : array[1..12] of string
    [3]             = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

  var
    i               : Integer;
    line            : StrTAD;

    function zeller(day, month, year : Integer) : Integer;
      { Compute the day of the week using Zeller's Congruence }

    var
      century         : Integer;

    begin
      if month > 2 then
        month := month-2
      else
        begin
          month := month+10;
          year := Pred(year)
        end;
      century := year div 100;
      year := year mod 100;
      zeller := (day-1+((13*month-1) div 5)+(5*year div 4)+century div 4-2*century+1) mod 7
    end;


  begin
    if (t[1] in [0..59]) and (t[2] in [0..23]) then
      line := intstr(t[2], 2)+':'+intstr(t[1], 2)
    else
      line := '';
    for i := 1 to Length(line) do
      if line[i] = ' ' then
        line[i] := '0';
    if (t[3] in [1..31]) and (t[4] in [1..12]) and (t[5] in [0..99]) then
      FormTAD := line+'  '+day[zeller(t[3], t[4], 1900+t[5])]+'day  '+intstr(t[3],
        2)+'-'+month[t[4]]+'-'+intstr(t[5], 2)
    else
      FormTAD := 'No Date'
  end;


  procedure send_time(size : Integer; var mm, ss : Integer);
    { Compute the file transfer time }

  var
    tr_time         : Real;

  begin
    tr_time := size*23.5/rate;    { Factor is empirically derived }
    mm := Trunc(tr_time);
    ss := Round(60.0*Frac(tr_time))
  end;



  procedure timer(var time_on, time_left : Integer);
    { Compute the time on and the time remaining to the current user }

  var
    t               : tad_array;
    give_extra      : Boolean;

  begin
    GetTAD(t);
    give_extra := False;
    time_on := 60*(t[2]-login_t[2])+t[1]-login_t[1];
    if time_on < 0 then
      time_on := time_on+1440;
    time_left := user_rec.limit+extra_time-time_on-user_rec.time_today;
    if extra_time_sw then
      begin
        if ExtraTimeStart < ExtraTimeStop then
          begin
            if (t[2] > ExtraTimeStart) and (t[2] < ExtraTimeStop) then
              give_extra := True;
          end
        else
          begin
            if (t[2] > ExtraTimeStart) and (t[2] < ExtraTimeStop+24) then
              give_extra := True;
            if (t[2] < ExtraTimeStart) and (t[2] < ExtraTimeStop) then
              give_extra := True;
          end;
        if give_extra then
          time_left := time_left+extra_time_val;
      end;
    if cmd_tail and (strint(ParamStr(1)) <> 99) and
    (strint(ParamStr(1)) <> 98)
    then
      if time_left > (time_to_event-time_on) then
        time_left := (time_to_event-time_on);
  end;



  procedure mesg_insert(TypMsg : Byte);
    { Insert message into linked list }

  var
    This            : MesgPtr;

  begin
    New(This);
    if MesgBase = nil then
      MesgBase := This
    else
      MesgLast^.next := This;
    MesgLast := This;
    MesgLast^.MesgNo := summ_rec.num;
    MesgLast^.SummLoc := Pred(FilePos(summ_file));
    MesgLast^.TypMsg := TypMsg;
    MesgLast^.next := nil
  end;



  procedure list(ch : Char);
    { List a portion of the system message file }

  var
    line_count      : Integer;
    This            : SysmPtr;

  begin
    This := SysmBase;
    while (This <> nil) and (This^.key <> ch) do
      This := This^.next;
    if This^.key = ch then
      begin
        WriteLn(com);
        Seek(sysm_file, Succ(This^.loc));
        Read(sysm_file, sysm_rec);
        line_count := 0;
        if ch <> 'B' then
          abort := False;
        while (not brk) and (not EoF(sysm_file)) and (sysm_rec[1] <> ':') do
          begin
            WriteLn(com, sysm_rec);
            Read(sysm_file, sysm_rec);
            if (user_rec.lines <> 99) and (ch <> 'W') and (ch <> 'F') then
              begin
                Inc(line_count);
                if line_count mod user_rec.lines = 0 then
                  pause
              end
          end
      end
  end;



  procedure Write_status_line;

  var
    Str             : StrTAD;
    date            : tad_array;

  begin
    date := user_rec.laston;
    Str := intstr(date[4], 2)+'/'+intstr(date[3], 2)+'/'+intstr(date[5], 2);
    putstat(user_rec.fn+' '+user_rec.ln+'  '+user_rec.cy+', '+user_rec.st+'   Phone: '+user_rec.ph
      , ' Last on: '+Str+'  Access: '+intstr(user_rec.access,
        1)+'  On today: '+intstr((time_on+user_rec.time_today),
          1)+'  Time Limit: '+intstr(user_rec.limit, 1)+'  '+intstr(rate, 1)+' Baud');
  end;



  procedure caps_to_mixed(var full_name : StrStd);

  var
    i, temp         : Integer;

  begin
    for i := 2 to Length(full_name) do
      if full_name[Pred(i)] <> Chr($20) then
        full_name[i] := LoCase(full_name[i]);
    temp := Pos(' Mc', full_name);
    if temp <> 0 then
      full_name[temp+3] := Upcase(full_name[temp+3]);
  end;


  procedure ScrollOn;

  begin
    if fconsole then
      begin
        Assign(lst, 'CON');
        Rewrite(lst);
        Write(lst, #27, '[>9;23z');
        Close(lst);
      end
    else
      ClrScr;
  end;


  procedure ScrollOff;

  begin
    if fconsole then
      begin
        Assign(lst, 'CON');
        Rewrite(lst);
        Write(lst, #27, '[>9;25z');
        Close(lst);
      end;
  end;


  {$F+}
  procedure NewExit; {$F-}

  var
    LogStr          : string[72];

  begin
    SetSect(HomName);
    Assign(temp_file, 'TPBUP.BB#');
    Erase(temp_file);
    if ErrorAddr <> nil then
      begin
        LogStr := ' @ '+HexPtr(ErrorAddr);
        log(10, LogStr);
        Str(ExitCode, LogStr);
        LogStr := 'Runtime '+LogStr;
        log(10, LogStr);
        ErrorAddr := nil;
        mdhangup;
      end;
    ExitCode := NetMsgEntr+EchoMsgEntr;
    ExitProc := ExitSave;
  end { NewExit } ;


  function greg_to_jul(day, mon, yr : Integer) : Real;
    { Convert from Gregorian date to Julian }

  var
    i               : Integer;

  begin
    i := (mon-14) div 12;
    greg_to_jul := day-32075+367*(mon-2-12*i) div 12-3*(yr+6800+i) div 400+365.25*(yr+6700+i)
  end;



  procedure check_time;
    {checks time on system and time left}

  begin
    timer(time_on, time_left);
    if time_left <= 0 then
      begin
        WriteLn(com, 'Access time expired.  Please call back tomorrow.', BEL, BEL, BEL);
        Delay((9600 div rate)*100);
        remote_online := False;
        mdhangup;
      end
    else if (time_left <= 5) and (time_left <> last_time_left) then
      begin
        WriteLn(com, 'Less than ', time_left, ' minutes of access time left.', BEL);
        last_time_left := time_left;
        WriteLn(com);
      end;
  end;



  {$F+}
  procedure UserEventCheck(EventNo, KbdFlagInfo : Word);
    {Background process called at every keypressed check}
    {This routine performs automatic word wrap if needed}

  const
    LastWhereX : Integer = 0;
    overflow : string = '';

  var
    next_inpstr, CharStr : string;
    ThisWhereX, i   : Integer;

  begin                           {UserEventCheck}
    if overflow <> '' then
      begin
        next_inpstr := StuffKey(overflow);
        overflow := next_inpstr;
      end
    else
      begin
        ThisWhereX := WhereX;
        if (ThisWhereX = 76) and (ReadCharAtCursor = ' ') then
          if ThisWhereX > LastWhereX then
            begin
              FlushKey;
              i := 0;
              CharStr := LeftArrow;
              repeat
                Inc(i);
                next_inpstr := StuffKey(CharStr);
                if next_inpstr <> '' then
                  overflow := overflow+next_inpstr;
                GoToXY(Pred(WhereX), WhereY);
              until ReadCharAtCursor = ' ';
              if i < 2 then
                next_inpstr := CR
              else
                next_inpstr := CR+DelKey+EndKey;
              next_inpstr := StuffKey(next_inpstr);
              if next_inpstr <> '' then
                overflow := overflow+next_inpstr;
            end;
        LastWhereX := ThisWhereX;
        if WhereY <> 2 then
          FastWrite('   '+DispName, 2, 47, 13);
      end;
  end;                            {UserEventCheck}


  procedure put_recs;

  begin
    Assign(sort_file, 'SORT.TMP');
    Reset(sort_file);
    with sort_rec do
      begin
        while (not EOF(sort_file)) do
          begin
            ReadLn(sort_file, first);
            ReadLn(sort_file, second);
            SortRelease(sort_rec);
          end;
      end;
    Close(sort_file);
    Erase(sort_file);
  end;


  procedure get_recs;

  begin
    while (not SortEOS) do
      begin
        SortReturn(sort_rec);
        with sort_rec do
          begin
            WriteLn(dir_file, first);
            WriteLn(dir_file, second);
            WriteLn(dir_file);
          end;
      end;
  end;


  function less_rec(var x, y : sort_typ) : Boolean;

  begin
    less_rec := ((x.first) < (y.first))
  end;
  {$F-}


end.                              { of CORE1.PAS }